home *** CD-ROM | disk | FTP | other *** search
/ EnigmA Amiga Run 1998 May / EnigmA AMIGA RUN 27 (1998)(G.R. Edizioni)(IT)[!][issue 1998-05].iso / earcd / sinclair-ql / pdtk_asm < prev    next >
Text File  |  1998-02-11  |  29KB  |  1,848 lines
  1.     SECTION PDTK
  2.     DATA    0
  3.  
  4.     NOLIST
  5.     INCLUDE 'QDOS_inc'
  6.     LIST
  7. ; --------------------------------------------------------------
  8. ; PDTK_asm - Freeware toolkit
  9. ;       - last modified 08/09/95
  10.  
  11. ;     ... by Mark J Swift - All rights reserved.
  12.  
  13. ; to assemble with the GST/QUANTA assembler use the command line:
  14. ;   PDTK_asm -nolink -nolist -bin PDTK_rext
  15.  
  16. ; to assemble with HISOFT DEVPAC remove the SECTION directive,
  17. ; and change the line "bra.l TK_START" to "bra TK_START"
  18.  
  19. ; set TABS to EIGHT characters before editing this file
  20.  
  21. ; --------------------------------------------------------------
  22. BASE:
  23.  
  24. ;  *** Comment out ONE of the following two lines to    ***
  25. ;  ***     create either a ROM or a BASIC toolkit.    ***
  26.  
  27.     bra.l    TK_START    ; ...If I'm a BASIC toolkit!
  28.  
  29. ;     dc.l     $4AFB0001     ; ...If I'm a ROM!
  30.  
  31.     dc.w    PROC_DEF-BASE
  32.     dc.w    ROM_START-BASE
  33.  
  34. BANNER:
  35.     dc.b    0,72,'PDTK Freeware BASIC toolkit v1.12',$A
  36.     dc.b    '1995 M J Swift - All rights reserved',$A
  37.  
  38. ; --------------------------------------------------------------
  39. ;  start of ROM code
  40. ; --------------------------------------------------------------
  41. TK_START:
  42.     movem.l d1-d3/a0-a3,-(a7)
  43.  
  44.     lea    PROC_DEF(pc),a1
  45.     move.w    BP.INIT,a2
  46.     jsr    (a2)
  47.  
  48.     lea    BANNER(pc),a1    ; start of message
  49.     suba.l    a0,a0        ; output channel 0
  50.     move.w    UT.MTEXT,a2
  51.     jsr    (a2)        ; print it
  52.  
  53.     bra.s    TK_DOIT
  54.  
  55. ROM_START:
  56.     movem.l d1-d3/a0-a3,-(a7)
  57.  
  58. TK_DOIT:
  59.     bsr    TKILL
  60.  
  61.     moveq    #ERR.OK,d0
  62.  
  63.     movem.l (a7)+,d1-d3/a0-a3
  64.     rts
  65.  
  66. ; -------------------------------------------------------------
  67. PROC_DEF:
  68.     dc.w    11
  69.     dc.w    PDTK_EXT-*
  70.     dc.b    8,'PDTK_EXT',0
  71.     dc.w    EXTRAS-*
  72.     dc.b    6,'EXTRAS',0
  73.     dc.w    TOOLKILL-*
  74.     dc.b    8,'TOOLKILL',0
  75.     dc.w    P_TRACE-*
  76.     dc.b    7,'P_TRACE'
  77.     dc.w    J_TRACE-*
  78.     dc.b    7,'J_TRACE'
  79.     dc.w    J_TRACE_W-*
  80.     dc.b    9,'J_TRACE_W'
  81. ;     dc.w     MC_TRACE-*
  82. ;     dc.b     8,'MC_TRACE',0
  83.     dc.w    0
  84.  
  85.     dc.w    4
  86.     dc.w    PDTK_VER-*
  87.     dc.b    9,'PDTK_VER$'
  88.     dc.w    WHERE-*
  89.     dc.b    5,'WHERE'
  90.     dc.w    F_TRACE-*
  91.     dc.b    7,'F_TRACE'
  92.  
  93.     dc.w    0
  94.  
  95. ; -------------------------------------------------------------
  96. PDTK_EXT:
  97.     lea    PDTK_DEF(pc),a1
  98.     move.w    $110,a2
  99.     jsr    (a2)
  100.  
  101.     bra.s    TKILL
  102.  
  103. ; -------------------------------------------------------------
  104. EXTRAS:
  105.     moveq    #1,d1
  106.     bsr    FETCH_CH
  107.     bne.s    EXTRASX
  108.  
  109.     cmp.l    a3,a5
  110.     bne    RPORT.BP
  111.  
  112.     move.l    a0,a4        ; channel ID
  113.     move.l    BV_NTBAS(a6),a3
  114.     move.l    BV_NTP(a6),a5
  115.  
  116. EX_TYPE:
  117.     move.w    0(a6,a3.l),d3
  118.     beq.s    EX_SKIP
  119.     cmp.w    #$0800,d3
  120.     beq.s    EX_CONT
  121.     cmp.w    #$0900,d3
  122.     bne.s    EX_SKIP
  123.  
  124. EX_CONT:
  125.     cmp.l    #$C000,4(a6,a3.l)
  126.     blt.s    EX_SKIP
  127.  
  128.     move.l    BV_NLBAS(a6),a1
  129.     adda.w    2(a6,a3.l),a1
  130.     move.b    0(a6,a1.l),d2
  131.     ext.w    d2        ; length of string
  132.     beq.s    EX_SKIP
  133.  
  134.     addq.l    #1,a1        ; address of string
  135.     move.l    a4,a0        ; channel ID
  136.     moveq    #-1,d3
  137.     trap    #4        ; relative to a6
  138.     moveq    #IO.SSTRG,d0
  139.     trap    #3        ; print string
  140.  
  141.     tst.l    d0
  142.     bne.s    EXTRASX
  143.  
  144.     moveq    #$0A,d1     ; linefeed
  145.     moveq    #-1,d3
  146.     moveq    #IO.SBYTE,d0
  147.     trap    #3
  148.  
  149.     tst.l    d0
  150.     bne.s    EXTRASX
  151.  
  152. EX_SKIP:
  153.     addq.l    #8,a3
  154.     cmp.l    a3,a5
  155.     bne    EX_TYPE
  156.  
  157.     moveq    #0,d0
  158.  
  159. EXTRASX:
  160.     rts
  161.  
  162. ; -------------------------------------------------------------
  163. TOOLKILL:
  164.     cmp.l    a3,a5
  165.     bne    RPORT.BP
  166.  
  167. TKILL:
  168.     move.l    BV_NTBAS(a6),a2
  169.     move.l    BV_NTP(a6),a5
  170.     bra    TK_TYPNXT
  171.  
  172. TK_TYPLUP:
  173.     move.w    0(a6,a5.l),d3
  174.     beq    TK_TYPNXT
  175.  
  176.     cmp.w    #$0900,d3
  177.     beq.s    TK_CONT
  178.  
  179.     cmp.w    #$0800,d3
  180.     bne    TK_TYPNXT
  181.  
  182. TK_CONT:
  183.     move.l    a5,a3
  184.     bra    TK_FNPRC
  185.  
  186. TK_DUPLUP:
  187.     move.w    0(a6,a3.l),d4
  188.     beq    TK_DUPNXT
  189.  
  190.     cmp.w    #$0800,d4
  191.     beq.s    TK_NPTR
  192.  
  193.     cmp.w    #$0900,d4
  194.     beq.s    TK_NPTR
  195.  
  196.     cmp.w    #$0303,d4
  197.     bgt.s    TK_DUPNXT
  198.  
  199. TK_NPTR:
  200.     move.l    BV_NLBAS(a6),a1
  201.     move.l    a1,a0
  202.     adda.w    2(a6,a4.l),a1    ; name list entry
  203.     adda.w    2(a6,a3.l),a0
  204.     move.b    0(a6,a1.l),d1    ; length of name
  205.     cmp.b    0(a6,a0.l),d1
  206.     bne.s    TK_DUPNXT
  207.  
  208.     ext.w    d1
  209.     beq.s    TK_DUPNXT
  210.  
  211.     subq.w    #1,d1
  212.  
  213. TK_NAMLUP:
  214.     addq.l    #1,a1
  215.     addq.l    #1,a0
  216.  
  217.     move.b    0(a6,a0.l),d0
  218.     move.b    0(a6,a1.l),d2
  219.     eor.b    d2,d0
  220.     andi.b    #223,d0     ; compare name
  221.     bne.s    TK_DUPNXT
  222.  
  223.     dbra    d1,TK_NAMLUP
  224.  
  225.     cmp.w    #$0303,d4
  226.     ble.s    TK_TYP3
  227.  
  228.     cmp.b    #'$',d2
  229.     bne.s    TK_TYP1
  230.  
  231.     move.w    #$0001,d4    ; set to unset $ var
  232.     bra.s    TK_TYP3
  233.  
  234. TK_TYP1:
  235.     cmp.b    #'%',d2
  236.     bne.s    TK_TYP2
  237.  
  238.     move.w    #$0003,d4    ; set to unset % var
  239.     bra.s    TK_TYP3
  240.  
  241. TK_TYP2:
  242.     move.w    #$0002,d4    ; set to unset FP var
  243.  
  244. TK_TYP3:
  245.     move.w    0(a6,a4.l),0(a6,a3.l) ; copy old to new
  246.     move.w    d4,0(a6,a4.l)          ; & set old type
  247.  
  248. ;     move.w  2(a6,a3.l),d0
  249. ;     move.w  2(a6,a4.l),2(a6,a3.l)
  250. ;     move.w  d0,2(a6,a4.l)          ; swap name pointer
  251. ;
  252.     move.l    4(a6,a3.l),d0
  253.     move.l    4(a6,a4.l),4(a6,a3.l)
  254.     move.l    d0,4(a6,a4.l)           ; swap 'value'
  255.  
  256.  
  257. TK_FNPRC:
  258.     move.l    a3,a4        ; new fn/proc
  259.  
  260. TK_DUPNXT:
  261.     subq.l    #8,a3
  262.     cmp.l    a3,a2
  263.     ble    TK_DUPLUP
  264.  
  265. TK_TYPNXT:
  266.     subq.l    #8,a5
  267.     cmp.l    a5,a2
  268.     ble    TK_TYPLUP
  269.  
  270. TK_EXIT:
  271.     moveq    #0,d0
  272.     rts
  273.  
  274. ; -------------------------------------------------------------
  275. PDTK_VER:
  276.     cmp.l    a3,a5
  277.     bne    RPORT.BP
  278.     move.l    #'1.12',d1
  279.     bra    RET_4S
  280.  
  281. ; -------------------------------------------------------------
  282. J_TRACE:
  283.     moveq    #0,d5
  284.     bra    J_TRC1
  285.  
  286. J_TRACE_W:
  287.     moveq    #-1,d5
  288.  
  289. J_TRC1:
  290.     moveq    #1,d7        ; old shared device
  291.  
  292.     bsr    FL_ID
  293.     bne    FEXIT
  294.  
  295.     move.l    a4,d4        ; channel ID to close
  296.  
  297.     bsr    HEDR1        ; read file header
  298.  
  299.     moveq    #ERR.BP,d0
  300.     cmp.l    a3,a5
  301.     bne    SDONE1
  302.  
  303.     moveq    #MT.CJOB,d0    ; create job in trns prog
  304.     moveq    #-1,d1        ; owner of job
  305.     move.l    0(a2),d2    ; length
  306.     move.l    6(a2),d3    ; dataspace
  307.     suba.l    a1,a1        ; start address
  308.     trap    #1
  309.     movea.l a0,a4        ; allocated start
  310.  
  311.     tst.l    d0
  312.     bne    SDONE1
  313.  
  314.     move.l    d1,d6        ; save Job ID
  315.  
  316.     move.l    d4,a0        ; File ID
  317.     move.l    a4,a1        ; location to load
  318.     moveq    #-1,d3        ; infinite timeout
  319.     moveq    #FS.LOAD,d0
  320.     trap    #3        ; load file
  321.  
  322.     bsr    SDONE1
  323.  
  324.     tst.l    d0
  325.     bne    J_TRCR
  326.  
  327.     ori.w    #$8000,-JB_END+JB_SR(a4) ; trace on
  328.  
  329.     moveq    #MT.ACTIV,d0    ; activate the job
  330.     move.l    d6,d1        ; restore Job ID
  331.     moveq    #$20,d2     ; priority
  332.     move.l    d5,d3        ; timeout
  333.     trap    #1
  334.  
  335.     tst.l    d0
  336.     bne.s    J_TRCR
  337.  
  338.     tst.l    d5
  339.     bne.s    J_TRCX
  340.  
  341.     moveq    #MT.SUSJB,d0    ; suspend a job
  342.     moveq    #-1,d1        ; me (usually BASIC)
  343.     moveq    #$19,d3     ; timeout
  344.     suba.l    a1,a1        ; no flag
  345.     trap    #1
  346.  
  347. J_TRCX:
  348.     rts
  349.  
  350. J_TRCR:
  351.     move.l    d0,d7        ; save error code
  352.     moveq    #MT.RJOB,d0    ; remove job
  353.     move.l    d6,d1        ; restore Job ID
  354.     trap    #1
  355.     move.l    d7,d0        ; restore error code
  356.     rts
  357.  
  358. ; -------------------------------------------------------------
  359. F_TRACE:
  360.     bsr    FETCH_S
  361.     bne.s    TRACEX
  362.  
  363.     bsr.s    WHEREIS     ; find address of FN/PROC
  364.  
  365.     cmpi.w    #$0900,d0
  366.     beq.s    TRACEON
  367.  
  368.     bra    RPORT.BP
  369. ; -------------------------------------------------------------
  370. P_TRACE:
  371.     bsr    FETCH_S
  372.     bne.s    TRACEX
  373.  
  374.     bsr.s    WHEREIS     ; find address of FN/PROC
  375.  
  376.     cmpi.w    #$0800,d0
  377.     bne    RPORT.BP
  378.  
  379. ; -------------------------------------------------------------
  380. TRACEON:
  381.     trap    #0        ; enter supervisor mode
  382.     ori.w    #$8000,sr    ; trace on
  383.     andi.w    #$DFFF,sr    ; enter user mode
  384.  
  385.     jsr    (a0)        ; do FN/PROC
  386.  
  387. TRACEOFF:
  388.     trap    #0        ; enter supervisor mode
  389.     andi.w    #$1FFF,sr    ; clear trace, exit supervisor
  390.  
  391. TRACEX:
  392.     rts
  393.  
  394. ; -------------------------------------------------------------
  395. ;MC_TRACE:
  396. ;     bsr     FETCH_W
  397. ;     bne.s     MC_TXIT
  398.  
  399. ;     tst.w     d1
  400. ;     beq.s     MC_TOFF
  401.  
  402. ;     trap     #0
  403. ;     ori.w     #$8000,sr
  404. ;     andi.w  #$DFFF,sr
  405. ;     rts
  406.  
  407. ;MC_TOFF:
  408. ;     trap     #0
  409. ;     andi.w  #$1FFF,sr
  410.  
  411. ;MC_TXIT:
  412. ;     rts
  413.  
  414. ; -------------------------------------------------------------
  415. WHERE:
  416.     bsr    FETCH_S
  417.     bne.s    WHEREX
  418.  
  419.     cmp.l    a3,a5
  420.     bne    RPORT.NO
  421.  
  422.     bsr.s    WHEREIS
  423.     move.l    a0,d1
  424.     bra    RET_L
  425.  
  426. WHEREX:
  427.  
  428. ; -------------------------------------------------------------
  429. ;  Enter: A1=pointer to fn/proc NAME (string) on math stack
  430.  
  431. ;   Exit: A1=updated pointer
  432. ;     D0=NAME type (i.e. proc=$0800, fn=$0900)
  433. ;     A0=address of fn/proc
  434.  
  435. WHEREIS:
  436.     movem.l d1-d2/a2-a5,-(a7)
  437.  
  438.     move.w    0(a6,a1.l),d0
  439.     beq.s    WHER_FAIL
  440.  
  441.     cmp.w    #256,d0
  442.     bcc.s    WHER_FAIL
  443.  
  444.     addq.l    #1,a1
  445.     move.l    a1,a3
  446.     move.l    BV_NTBAS(a6),a4
  447.     move.l    BV_NTP(a6),a5
  448.  
  449. WHER_LUP1:
  450.     move.l    BV_NLBAS(a6),a2
  451.     add.w    2(a6,a4.l),a2
  452.     move.b    0(a6,a1.l),d0
  453.     cmp.b    0(a6,a2.l),d0
  454.     bne.s    WHER_NXT
  455.     ext.w    d0
  456.     subq.w    #1,d0
  457.  
  458. WHER_LUP2:
  459.     addq.l    #1,a1
  460.     addq.l    #1,a2
  461.     move.b    0(a6,a1.l),d1
  462.     move.b    0(a6,a2.l),d2
  463.     eor.b    d2,d1
  464.     andi.b    #$DF,d1
  465.     bne.s    WHER_NXT
  466.     dbra    d0,WHER_LUP2
  467.     move.w    0(a6,a4.l),d0    ; type
  468.     move.l    4(a6,a4.l),a0    ; address
  469.     bra.s    WHER_RTS
  470.  
  471. WHER_NXT:
  472.     move.l    a3,a1
  473.     addq.l    #8,a4
  474.     cmp.l    a5,a4
  475.     bne    WHER_LUP1
  476.  
  477. WHER_FAIL:
  478.     moveq    #0,d0
  479.     move.l    d0,a0
  480.  
  481. WHER_RTS:
  482.     move.l    a3,a1
  483.     subq.l    #1,a1
  484.  
  485.     moveq    #3,d1        ; get total length of string
  486.     add.w    0(a6,a1.l),d1
  487.     bclr    #0,d1
  488.     add.l    d1,a1        ; and update a1
  489.  
  490.     movem.l (a7)+,d1-d2/a2-a5
  491.     rts
  492.  
  493. ; -------------------------------------------------------------
  494. PDTK_DEF:
  495.     dc.w    15
  496.  
  497.     dc.w    RESET-*
  498.     dc.b    5,'RESET'
  499.     dc.w    RECHP-*
  500.     dc.b    5,'RECHP'
  501.     dc.w    CLCHP-*
  502.     dc.b    5,'CLCHP'
  503.     dc.w    LRESPR-*
  504.     dc.b    6,'LRESPR',0
  505.     dc.w    DDLIST-*
  506.     dc.b    6,'DDLIST',0
  507.     dc.w    SACS-*
  508.     dc.b    9,'SET_FACCS'
  509.     dc.w    STYP-*
  510.     dc.b    8,'SET_FTYP',0
  511.     dc.w    SDAT-*
  512.     dc.b    8,'SET_FDAT',0
  513.     dc.w    SXTRA-*
  514.     dc.b    9,'SET_FXTRA'
  515.     dc.w    CURSEN-*
  516.     dc.b    6,'CURSEN',0
  517.     dc.w    CURDIS-*
  518.     dc.b    6,'CURDIS',0
  519.  
  520.     dc.w    0
  521.  
  522.     dc.w    23
  523.  
  524.     dc.w    QDOS-*
  525.     dc.b    5,'QDOS$'
  526.     dc.w    SYSBASE-*
  527.     dc.b    7,'SYSBASE'
  528.     dc.w    ALCHP-*
  529.     dc.b    5,'ALCHP'
  530.     dc.w    FREE_MEM-*
  531.     dc.b    8,'FREE_MEM',0
  532.     dc.w    FLEN-*
  533.     dc.b    4,'FLEN',0
  534.     dc.w    FACS-*
  535.     dc.b    5,'FACCS'
  536.     dc.w    FTYP-*
  537.     dc.b    4,'FTYP',0
  538.     dc.w    FDAT-*
  539.     dc.b    4,'FDAT',0
  540.     dc.w    FXTRA-*
  541.     dc.b    5,'FXTRA'
  542.     dc.w    FTEST-*
  543.     dc.b    5,'FTEST'
  544.     dc.w    DDTEST-*
  545.     dc.b    6,'DDTEST',0
  546.     dc.w    HEXS-*
  547.     dc.b    4,'HEX$',0
  548.     dc.w    HEX-*
  549.     dc.b    3,'HEX'
  550.     dc.w    INTEGERS-*
  551.     dc.b    8,'INTEGER$',0
  552.     dc.w    LONGINTS-*
  553.     dc.b    8,'LONGINT$',0
  554.     dc.w    FLOATS-*
  555.     dc.b    6,'FLOAT$',0
  556.     dc.w    STRINGS-*
  557.     dc.b    7,'STRING$'
  558.     dc.w    STRINGI-*
  559.     dc.b    7,'STRING%'
  560.     dc.w    STRINGL-*
  561.     dc.b    7,'STRINGL'
  562.     dc.w    STRINGF-*
  563.     dc.b    7,'STRINGF'
  564.  
  565.     dc.w    0
  566.  
  567. ; -------------------------------------------------------------
  568. QDOS:
  569.     cmp.l    a3,a5
  570.     bne    RPORT.BP
  571.     moveq    #MT.INF,d0
  572.     trap    #1
  573.     move.l    d2,d1
  574.     bra    RET_4S
  575.  
  576. ; -------------------------------------------------------------
  577. SYSBASE:
  578.     cmp.l    a3,a5
  579.     bne    RPORT.BP
  580.     moveq    #MT.INF,d0
  581.     trap    #1
  582.     move.l    a0,d1
  583.     bra    RET_L
  584.  
  585. ; -------------------------------------------------------------
  586. RESET:
  587.     cmp.l    a3,a5
  588.     bne    RPORT.BP
  589.  
  590.     trap    #0
  591.     ori.w    #$0700,sr
  592.  
  593.     move.l    $0,a7        ; reset supervisor stack
  594.  
  595.     move.l    a7,d0
  596.     andi.l    #$FFFF8000,d0
  597.     move.l    d0,a6
  598.  
  599.     suba.l    a0,a0
  600.  
  601.     tst.b    161(a6)     ; skip if not 010+
  602.     beq.s    RESET2
  603.  
  604.     dc.w    $4E7A,$8801    ; movec vbr,a0
  605.  
  606. RESET2:
  607.     move.l    $4(a0),-(a7)    ; jump to reset routine
  608.     rts
  609.  
  610. ; -------------------------------------------------------------
  611. RECHP:
  612.     bsr    FETCH_L
  613.     bne.s    RECHX
  614.  
  615.     cmp.l    a3,a5
  616.     bne    RPORT.BP
  617.  
  618.     subq.l    #4,d1        ; compensate for link
  619.  
  620.     lea    $E0(a6),a1    ; BASICs list of allocations
  621. RECHL:
  622.     move.l    (a1),d0
  623.     beq    RPORT.OR    ; indicate error if no link
  624.  
  625.     move.l    d0,a1
  626.     cmp.l    d0,d1        ; look for allocation in list
  627.     bne.s    RECHL
  628.  
  629.     move.l    d1,a0        ; address of link
  630.     lea    $E0(a6),a1    ; BASICs list of allocations
  631.     move.w    UT.UNLNK,a4
  632.     jsr    (a4)        ; remove from linked list
  633.  
  634.     moveq    #MT.RECHP,d0
  635.     trap    #1        ; release memory
  636.  
  637. RECHX:
  638.     rts
  639.  
  640. ; -------------------------------------------------------------
  641. CLCHP:
  642.     cmp.l    a3,a5
  643.     bne    RPORT.BP
  644.  
  645.     lea    $E0(a6),a1    ; BASICs list of allocations
  646.     move.l    (a1),d0
  647.     beq.s    CLCHPX
  648.  
  649.     clr.l    (a1)
  650. CLCHPL:
  651.     move.l    d0,a4
  652.     move.l    d0,a0
  653.     moveq    #MT.RECHP,d0
  654.     trap    #1
  655.     move.l    (a4),d0
  656.     bne.s    CLCHPL
  657.  
  658. CLCHPX:
  659.     rts
  660.  
  661. ; -------------------------------------------------------------
  662. ;    ALCHP(HP.REQ)
  663. ; or ALCHP(JB.ID,HP.REQ)
  664. ; or ALCHP(JB.NUM,JB.TAG,HP.REQ)
  665.  
  666. ALCHP:
  667.     move.l    a5,d5
  668.     sub.l    a3,d5
  669.     beq    RPORT.BP
  670.  
  671.     moveq    #-1,d2        ; default job ID
  672.  
  673.     cmp.w    #1*8,d5     ; one parameter?
  674.     beq.s    ALCH1P
  675.  
  676.     cmp.w    #3*8,d5
  677.     bgt    RPORT.BP
  678.  
  679.     move.l    a5,-(a7)
  680.     lea    -8(a5),a5
  681.     bsr    FETCH_ID    ; get job ID
  682.     movea.l a5,a3
  683.     movea.l (a7)+,a5
  684.     bne.s    ALCHX
  685.     move.l    d1,d2        ; in d2!
  686.  
  687. ALCH1P:
  688.     bsr    FETCH_L
  689.     bne.s    ALCHX
  690.  
  691.     tst.l    d1
  692.     ble    RPORT.OR    ; shouldn't allocate nought
  693.  
  694.     addq.l    #4,d1        ; room for link
  695.  
  696.     moveq    #MT.ALCHP,d0
  697.     trap    #1
  698.     tst.l    d0
  699.     bne.s    ALCHX
  700.  
  701.     lea    $E0(a6),a1    ; BASICs list of allocations
  702.     move.w    UT.LINK,a4
  703.     jsr    (a4)        ; add to linked list
  704.  
  705.     move.l    a0,d1        ; address of allocation
  706.     addq.l    #4,d1        ; skip over link
  707.  
  708.     bra    RET_L
  709.  
  710. ALCHX:
  711.     rts
  712.  
  713. ; -------------------------------------------------------------
  714. FREE_MEM:
  715.     moveq    #MT.INF,d0
  716.     trap    #1
  717.     move.l    SV_BASIC(a0),d1
  718.     sub.l    SV_FREE(a0),d1
  719.     subi.l    #$400,d1    ; a bit of lea-way
  720.     bra    RET_L
  721.  
  722. ; -------------------------------------------------------------
  723. LRESPR:
  724.     moveq    #1,d7        ; old shared device
  725.  
  726.     bsr    FL_ID
  727.     bne    FEXIT
  728.  
  729.     move.l    a4,d4        ; channel ID to close
  730.  
  731.     bsr    HEDR1        ; read file header
  732.  
  733.     moveq    #ERR.BP,d0
  734.     cmp.l    a3,a5
  735.     bne    SDONE1
  736.  
  737.     move.l    0(a2),d1    ; get length of file
  738.  
  739.     movem.l d1/a2,-(a7)    ; save len & header buffer
  740.  
  741.     moveq    #MT.ALRES,d0
  742.     trap    #1        ; allocate space
  743.     move.l    a0,a1        ; location
  744.  
  745.     movem.l (a7)+,d2/a2    ; restore len & header buffer
  746.  
  747.     tst.l    d0
  748.     bne    SDONE1        ; no room so quit
  749.  
  750.     move.l    a1,-(a7)    ; stack return address
  751.  
  752.     move.l    a4,a0        ; File ID
  753.     moveq    #-1,d3        ; infinite timeout
  754.     moveq    #FS.LOAD,d0
  755.     trap    #3        ; load file
  756.  
  757.     tst.l    d0
  758.     beq    SDONE1        ; no errors.
  759.  
  760.     addq.l    #4,a7        ; failed to load
  761.  
  762.     bra    SDONE1
  763.  
  764. ; -------------------------------------------------------------
  765. FLEN:
  766.     moveq    #1,d7        ; old shared device
  767.  
  768.     bsr    FGEN
  769.     bne    SDONE1
  770.  
  771.     moveq    #ERR.BP,d0
  772.     cmp.l    a3,a5
  773.     bne    SDONE1
  774.  
  775.     move.l    0(a2),d6
  776.     bra.s    FDONE
  777.  
  778. ; -------------------------------------------------------------
  779. FACS:
  780.     moveq    #1,d7        ; old shared device
  781.  
  782.     bsr    FGEN
  783.     bne    SDONE1
  784.  
  785.     moveq    #ERR.BP,d0
  786.     cmp.l    a3,a5
  787.     bne    SDONE1
  788.  
  789.     move.b    4(a2),d6
  790.     ext.w    d6
  791.     ext.l    d6
  792.     bra.s    FDONE
  793.  
  794. ; -------------------------------------------------------------
  795. FTYP:
  796.     moveq    #1,d7        ; old shared device
  797.  
  798.     bsr    FGEN
  799.     bne    SDONE1
  800.  
  801.     moveq    #ERR.BP,d0
  802.     cmp.l    a3,a5
  803.     bne    SDONE1
  804.  
  805.     move.b    5(a2),d6
  806.     ext.w    d6
  807.     ext.l    d6
  808.     bra.s    FDONE
  809.  
  810. ; -------------------------------------------------------------
  811. FDAT:
  812.     moveq    #1,d7        ; old shared device
  813.  
  814.     bsr    FGEN
  815.     bne    SDONE1
  816.  
  817.     moveq    #ERR.BP,d0
  818.     cmp.l    a3,a5
  819.     bne    SDONE1
  820.  
  821.     move.l    6(a2),d6
  822.     bra.s    FDONE
  823.  
  824. ; -------------------------------------------------------------
  825. FXTRA:
  826.     moveq    #1,d7        ; old shared device
  827.  
  828.     bsr    FGEN
  829.     bne    SDONE1
  830.  
  831.     moveq    #ERR.BP,d0
  832.     cmp.l    a3,a5
  833.     bne.s    SDONE1
  834.  
  835.     move.l    $A(a2),d6
  836.  
  837. ; -------------------------------------------------------------
  838. FDONE:
  839.     moveq    #ERR.OK,d0    ; no errors
  840.  
  841.     bsr.s    SDONE1
  842.  
  843. FDONE1:
  844.     move.l    d6,d1
  845.     bra    RET_L
  846.  
  847. ; -------------------------------------------------------------
  848. FEXIT:
  849.     rts
  850.  
  851. ; -------------------------------------------------------------
  852. SACS:
  853.     moveq    #0,d7        ; old exclusive device
  854.  
  855.     bsr    FGEN
  856.     bne.s    SDONE1
  857.  
  858.     bsr    FETCH_W
  859.     bne.s    SDONE1
  860.  
  861.     moveq    #ERR.BP,d0
  862.     cmp.l    a3,a5
  863.     bne.s    SDONE1
  864.  
  865.     move.b    d1,4(a2)
  866.     bra.s    SDONE
  867.  
  868. ; -------------------------------------------------------------
  869. STYP:
  870.     moveq    #0,d7        ; old exclusive device
  871.  
  872.     bsr.s    FGEN
  873.     bne.s    SDONE1
  874.  
  875.     bsr    FETCH_W
  876.     bne.s    SDONE1
  877.  
  878.     moveq    #ERR.BP,d0
  879.     cmp.l    a3,a5
  880.     bne.s    SDONE1
  881.  
  882.     move.b    d1,5(a2)
  883.     bra.s    SDONE
  884.  
  885. ; -------------------------------------------------------------
  886. SDAT:
  887.     moveq    #0,d7        ; old exclusive device
  888.  
  889.     bsr.s    FGEN
  890.     bne.s    SDONE1
  891.  
  892.     bsr    FETCH_L
  893.     bne.s    SDONE1
  894.  
  895.     moveq    #ERR.BP,d0
  896.     cmp.l    a3,a5
  897.     bne.s    SDONE1
  898.  
  899.     move.l    d1,6(a2)
  900.     bra.s    SDONE
  901.  
  902. ; -------------------------------------------------------------
  903. SXTRA:
  904.     moveq    #0,d7        ; old exclusive device
  905.  
  906.     bsr.s    FGEN
  907.     bne.s    SDONE1
  908.  
  909.     bsr    FETCH_L
  910.     bne.s    SDONE1
  911.  
  912.     moveq    #ERR.BP,d0
  913.     cmp.l    a3,a5
  914.     bne.s    SDONE1
  915.  
  916.     move.l    d1,$A(a2)
  917.  
  918. ; -------------------------------------------------------------
  919. SDONE:
  920.     moveq    #ERR.OK,d0    ; no errors
  921.  
  922.     move.l    a4,a0        ; channel ID
  923.     move.l    a2,a1        ; location of header
  924.     moveq    #14,d2
  925.     moveq    #-1,d3
  926.     moveq    #FS.HEADS,d0    ; set header
  927.     trap    #3
  928.  
  929. SDONE1:
  930.     move.l    d0,d7        ; save error code
  931.  
  932.     move.l    a2,d0
  933.     beq.s    SDONE2
  934.  
  935.     move.l    a2,a0
  936.     moveq    #MT.RECHP,d0
  937.     trap    #1        ; release buffer
  938.  
  939. SDONE2:
  940.     tst.l    d4
  941.     beq.s    SEXIT
  942.  
  943.     move.l    d4,a0
  944.     moveq    #IO.CLOSE,d0    ; close file
  945.     trap    #2
  946.  
  947. SEXIT:
  948.     move.l    d7,d0        ; restore error code
  949.  
  950.     rts
  951.  
  952. ; -------------------------------------------------------------
  953. FGEN:
  954.     moveq    #0,d4        ; no channel to close yet
  955.  
  956.     bsr    BKSLSH
  957.     beq.s    FGEN1
  958.  
  959.     moveq    #1,d1        ; default channel
  960.     bsr    FETCH_CH
  961.     bne.s    FGENX
  962.  
  963.     move.l    a0,a4        ; store channel ID
  964.     bra.s    FGEN3
  965.  
  966. FGEN1:
  967.     bsr    FETCH_N
  968.     bne.s    FGENX
  969.  
  970. FGEN2:
  971.     bsr.s    FL_ID
  972.     bne.s    FGENX
  973.  
  974.     move.l    a4,d4        ; channel ID to close
  975.  
  976. FGEN3:
  977.     bsr.s    HEDR1        ; read file header
  978.  
  979. FGENX:
  980.     rts
  981.  
  982. ; -------------------------------------------------------------
  983. FL_ID:
  984.     bsr    GET1_FNAMES
  985.     bne.s    FL_IDX
  986.  
  987. FL_ID1:
  988.     moveq    #0,d1
  989.     move.w    0(a6,a1.l),d1    ; length of filename
  990.  
  991.     move.l    a1,a0        ; address of filename
  992.     move.l    d7,d3        ; shared or exclusive...
  993.     moveq    #-1,d1        ; current job
  994.     trap    #4        ; relative to a6
  995.     moveq    #IO.OPEN,d0    ; try to open file
  996.     trap    #2
  997.  
  998.     tst.l    d0
  999.     bne.s    FL_IDX        ; error
  1000.  
  1001.     move.l    a0,a4        ; store channel ID
  1002.  
  1003. FL_IDX:
  1004.     rts
  1005.  
  1006. ; -------------------------------------------------------------
  1007. HEDR1:
  1008.     movem.l d2-d3/d7/a1/a3,-(a7)
  1009.  
  1010.     moveq    #64,d1        ; space required
  1011.     moveq    #-1,d2        ; owner job = me
  1012.     moveq    #MT.ALCHP,d0
  1013.     trap    #1
  1014.  
  1015.     tst.l    d0
  1016.     bne.s    HEDRX
  1017.  
  1018.     move.l    a0,a2        ; address of buffer
  1019.  
  1020.     move.l    a4,a0        ; channel ID
  1021.     move.l    a2,a1        ; location for header
  1022.     moveq    #64,d2
  1023.     moveq    #-1,d3
  1024.     moveq    #FS.HEADR,d0    ; get 64 bytes of header
  1025.     trap    #3
  1026.  
  1027.     tst.l    d0
  1028.     beq.s    HEDRX        ; no errors... exit
  1029.  
  1030.     move.l    d0,d7        ; save error code
  1031.  
  1032.     move.l    a2,a0
  1033.     moveq    #MT.RECHP,d0
  1034.     trap    #1        ; release buffer
  1035.     suba.l    a2,a2        ; indicate no buffer
  1036.  
  1037.     move.l    d7,d0        ; restore error
  1038.  
  1039. HEDRX:
  1040.     movem.l (a7)+,d2-d3/d7/a1/a3
  1041.     rts
  1042.  
  1043. ; -------------------------------------------------------------
  1044. FTEST:
  1045.     bsr    GET1_FNAMES
  1046.     bne    RPORT.BP
  1047.  
  1048.     cmp.l    a3,a5
  1049.     bne    RPORT.BP
  1050.  
  1051.     moveq    #0,d1
  1052.     move.w    0(a6,a1.l),d1    ; length of filename
  1053.  
  1054.     move.l    a1,a0        ; address of filename
  1055.     moveq    #0,d3        ; old exclusive device
  1056.     moveq    #-1,d1        ; current job
  1057.     trap    #4        ; relative to a6
  1058.     moveq    #IO.OPEN,d0    ; try to open file
  1059.     trap    #2
  1060.  
  1061.     move.l    d0,d6
  1062.     bne.s    FTEST1
  1063.  
  1064.     moveq    #IO.CLOSE,d0    ; close file
  1065.     trap    #2
  1066.  
  1067. FTEST1:
  1068.     move.l    d6,d1
  1069.     bra    RET_L
  1070.  
  1071. ; -------------------------------------------------------------
  1072. DDTEST:
  1073.     bsr    FETCH_S
  1074.     bne    RPORT.BP
  1075.  
  1076.     cmp.l    a3,a5
  1077.     bne    RPORT.BP
  1078.  
  1079.     moveq    #MT.INF,d0
  1080.     trap    #1
  1081.     move.l    SV_DDLST(a0),a0
  1082.  
  1083.     bra.s    DDTST1
  1084.  
  1085. DDTSTL:
  1086.     move.l    (a0),a0
  1087.  
  1088. DDTST1:
  1089.     move.l    a0,d0
  1090.     beq.s    DDTST.NF    ; device not in list
  1091.  
  1092.     lea    $24(a0),a4    ; address of name
  1093.  
  1094.     move.l    a1,a2
  1095.  
  1096.     move.w    (a4)+,d0
  1097.     cmp.w    0(a6,a2.l),d0
  1098.     bne.s    DDTSTL
  1099.  
  1100.     addq.l    #2,a2
  1101.     bra.s    DDTST2
  1102.  
  1103. DDTSTL2:
  1104.     move.b    (a4)+,d1
  1105.     move.b    0(a6,a2.l),d2
  1106.     eor.b    d2,d1
  1107.     andi.b    #$DF,d1
  1108.     bne.s    DDTSTL
  1109.  
  1110.     addq.l    #1,a2
  1111.  
  1112. DDTST2:
  1113.     dbra    d0,DDTSTL2
  1114.  
  1115.     moveq    #ERR.OK,d1
  1116.     bra.s    DDTSTX
  1117.  
  1118. DDTST.NF:
  1119.     moveq    #ERR.NF,d1
  1120.  
  1121. DDTSTX:
  1122.     bra    RET_L
  1123.  
  1124. ; -------------------------------------------------------------
  1125. DDLIST:
  1126.     moveq    #1,d1
  1127.     bsr    FETCH_CH
  1128.     bne.s    DDLISTX
  1129.  
  1130.     cmp.l    a3,a5
  1131.     bne    RPORT.BP
  1132.  
  1133.     move.l    a0,a3        ; save channel id
  1134.  
  1135.     moveq    #MT.INF,d0
  1136.     trap    #1        ; get address of sys vars in a0
  1137.     move.l    SV_DDLST(a0),a4 ; address of first device driver
  1138.     move.l    a3,a0        ; restore channel id
  1139.  
  1140. DDLISTL:
  1141.     lea    $24(a4),a1
  1142.     bsr    IOSTRG
  1143.     bne.s    DDLISTX
  1144.  
  1145.     moveq    #$0A,d1     ; linefeed
  1146.     moveq    #-1,d3
  1147.     moveq    #IO.SBYTE,d0
  1148.     trap    #3
  1149.  
  1150.     tst.l    d0
  1151.     bne.s    DDLISTX
  1152.  
  1153.     move.l    (a4),a4
  1154.     move.l    a4,d0
  1155.     tst.l    d0
  1156.     bne.s    DDLISTL
  1157.  
  1158. DDLISTX:
  1159.     rts
  1160.  
  1161. ; -------------------------------------------------------------
  1162. HEXS:
  1163.     bsr    FETCH_L
  1164.     bne.s    HEXSX
  1165.  
  1166.     move.l    d1,d2
  1167.     bsr    FETCH_W
  1168.     bne.s    HEXSX
  1169.  
  1170.     cmp.l    a3,a5
  1171.     bne    RPORT.BP
  1172.  
  1173.     cmp.w    #32,d1
  1174.     bgt    RPORT.OR
  1175.  
  1176.     addq.w    #3,d1
  1177.     lsr.w    #2,d1        ; number of digits
  1178.     beq    RPORT.OR
  1179.  
  1180.     move.l    BV_RIP(a6),a1
  1181.  
  1182.     btst    #0,d1
  1183.     beq.s    HEXS1
  1184.  
  1185.     subq.l    #1,a1
  1186.  
  1187. HEXS1:
  1188.     move.w    d1,d3
  1189.     subq.w    #1,d3
  1190. HEXSL:
  1191.     move.l    d2,d0
  1192.     andi.b    #15,d0
  1193.     cmpi.b    #10,d0
  1194.     blt.s    HEXS2
  1195.  
  1196.     addq.b    #7,d0
  1197. HEXS2:
  1198.     addi.b    #48,d0
  1199.     subq.l    #1,a1
  1200.     move.b    d0,0(a6,a1.l)
  1201.     lsr.l    #4,d2
  1202.     dbra    d3,HEXSL
  1203.  
  1204.     subq.l    #2,a1
  1205.     move.w    d1,0(a6,a1.l)
  1206.     move.l    a1,BV_RIP(a6)
  1207.  
  1208.     moveq    #1,d4
  1209.     moveq    #ERR.OK,d0
  1210.  
  1211. HEXSX:
  1212.     rts
  1213.  
  1214. ; -------------------------------------------------------------
  1215. HEX:
  1216.     bsr    FETCH_S
  1217.     bne    RPORT.BP
  1218.  
  1219.     cmp.l    a3,a5
  1220.     bne    RPORT.BP
  1221.  
  1222.     move.w    0(a6,a1.l),d1
  1223.     beq    RPORT.BP
  1224.  
  1225.     cmp.w    #8,d1
  1226.     bgt    RPORT.BP
  1227.  
  1228.     addq.l    #2,a1
  1229.     subq.w    #1,d1
  1230.     moveq    #0,d2
  1231.  
  1232. HEXL:
  1233.     move.b    0(a6,a1.l),d0
  1234.     addq.l    #1,a1
  1235.     subi.b    #48,d0
  1236.     bmi    RPORT.OR
  1237.  
  1238.     cmpi.b    #10,d0
  1239.     blt.s    HEX1
  1240.  
  1241.     andi.b    #223,d0
  1242.  
  1243.     cmpi.b    #17,d0
  1244.     blt    RPORT.OR
  1245.  
  1246.     subq.b    #7,d0
  1247.  
  1248.     cmpi.b    #15,d0
  1249.     bgt    RPORT.OR
  1250. HEX1:
  1251.     lsl.l    #4,d2
  1252.     or.b    d0,d2
  1253.  
  1254.     dbra    d1,HEXL
  1255.  
  1256.     move.l    d2,d1
  1257.     bra    RET_L
  1258.  
  1259. ; -------------------------------------------------------------
  1260. STRINGL:
  1261.     bsr    FETCH_S
  1262.     bne    RPORT.BP
  1263.  
  1264.     cmp.l    a3,a5
  1265.     bne    RPORT.BP
  1266.  
  1267.     move.w    0(a6,a1.l),d1
  1268.     cmp.w    #4,d1
  1269.     bne    RPORT.BP
  1270.  
  1271.     move.l    2(a6,a1.l),d1
  1272.  
  1273.     bra    RET_L
  1274.  
  1275. ; -------------------------------------------------------------
  1276. STRINGI:
  1277.     bsr    FETCH_S
  1278.     bne    RPORT.BP
  1279.  
  1280.     cmp.l    a3,a5
  1281.     bne    RPORT.BP
  1282.  
  1283.     moveq    #2,d2
  1284.     moveq    #3,d4
  1285.     bra.s    NUMFORM
  1286.  
  1287. ; -------------------------------------------------------------
  1288. STRINGF:
  1289.     bsr    FETCH_S
  1290.     bne    RPORT.BP
  1291.  
  1292.     cmp.l    a3,a5
  1293.     bne    RPORT.BP
  1294.  
  1295.     moveq    #6,d2
  1296.     moveq    #2,d4
  1297.  
  1298. NUMFORM:
  1299.     move.w    0(a6,a1.l),d1
  1300.     cmp.w    d2,d1
  1301.     bne    RPORT.BP
  1302.     addq.l    #2,a1
  1303.     move.l    a1,BV_RIP(a6)
  1304.     rts
  1305.  
  1306. ; -------------------------------------------------------------
  1307. INTEGERS:
  1308.     bsr    FETCH_W
  1309.     bne    RPORT.BP
  1310.  
  1311.     cmp.l    a3,a5
  1312.     bne    RPORT.BP
  1313.  
  1314.     moveq    #2,d4
  1315.     bra.s    STRFORM
  1316.  
  1317. ; -------------------------------------------------------------
  1318. LONGINTS:
  1319.     move.w    CA.GTLIN,a2
  1320.     bsr    GET_ONE
  1321.     bne    RPORT.BP
  1322.  
  1323.     cmp.l    a3,a5
  1324.     bne    RPORT.BP
  1325.  
  1326.     moveq    #4,d4
  1327.     bra.s    STRFORM
  1328.  
  1329. ; -------------------------------------------------------------
  1330. FLOATS:
  1331.     bsr    FETCH_F
  1332.     bne    RPORT.BP
  1333.  
  1334.     cmp.l    a3,a5
  1335.     bne    RPORT.BP
  1336.  
  1337.     moveq    #6,d4
  1338.     bra.s    STRFORM
  1339.  
  1340. ; -------------------------------------------------------------
  1341. STRINGS:
  1342.     bsr    FETCH_S
  1343.     bne    RPORT.BP
  1344.  
  1345.     cmp.l    a3,a5
  1346.     bne    RPORT.BP
  1347.  
  1348.     move.w    0(a6,a1.l),d4
  1349.     addq.w    #2,d4
  1350.  
  1351. STRFORM:
  1352. ;     moveq.l  #2,d1
  1353. ;     move.w  BV.CHRIX,a2
  1354. ;     jsr     (a2)
  1355.  
  1356.     subq.l    #2,a1        ; 2 bytes for string len
  1357.     move.l    a1,BV_RIP(a6)
  1358.  
  1359.     move.w    d4,0(a6,a1.l)
  1360.     moveq    #1,d4
  1361.     moveq    #0,d0
  1362.     rts
  1363.  
  1364. ; -------------------------------------------------------------
  1365. CURSEN:
  1366.     moveq    #SD.CURE,d5
  1367.     bra.s    CURSR
  1368.  
  1369. CURDIS:
  1370.     moveq    #SD.CURS,d5
  1371.  
  1372. CURSR:
  1373.     moveq    #1,d1
  1374.     bsr    FETCH_CH
  1375.     bne.s    CURSR_X
  1376.  
  1377.     cmp.l    a3,a5
  1378.     bne    RPORT.BP
  1379.  
  1380.     move.w    #-1,d3
  1381.     move.b    d5,d0
  1382.     trap    #3
  1383. CURSR_X:
  1384.     rts
  1385.  
  1386. ; -------------------------------------------------------------
  1387. ; Entry: A3.L    pointer to first parameter
  1388. ;    A5.L   pointer to last parameter
  1389. ;
  1390. ; Exit: A3.L   updated
  1391. ;    A5.L   updated
  1392. ;    A1.L   pointer to result
  1393. ;    D0.L...error code
  1394. ;    D1.W   result (or mantissa or string length)
  1395.  
  1396. ; Fetch one null parameter
  1397.  
  1398. FETCH_N:
  1399.     move.b    1(a6,a1.l),d0
  1400.     andi.w    #$0F,d0
  1401.     bne    RPORT.BP
  1402.  
  1403.     addq.l    #8,a3
  1404.     rts
  1405.  
  1406. ; --------------------------------------------------------------
  1407. ; Fetch one Word
  1408.  
  1409. FETCH_W:
  1410.     movem.l a2,-(a7)
  1411.  
  1412.     move.w    CA.GTINT,a2
  1413.     bsr    GET_ONE
  1414.     bne.s    FETCH_WX
  1415.  
  1416.     move.l    a1,BV_RIP(a6)
  1417.     moveq    #0,d1
  1418.     move.w    0(a6,a1.l),d1
  1419.     addq.l    #2,BV_RIP(a6)
  1420.  
  1421. FETCH_WX:
  1422.     movem.l (a7)+,a2
  1423.     tst.l    d0
  1424.     rts
  1425.  
  1426. ; --------------------------------------------------------------
  1427. ; Fetch one long word
  1428.  
  1429. FETCH_L:
  1430.     movem.l a2,-(a7)
  1431.  
  1432.     move.w    CA.GTLIN,a2
  1433.     bsr.s    GET_ONE
  1434.     bne.s    FETCH_LX
  1435.  
  1436.     move.l    a1,BV_RIP(a6)
  1437.     move.l    0(a6,a1.l),d1
  1438.     addq.l    #4,BV_RIP(a6)
  1439.  
  1440. FETCH_LX:
  1441.     movem.l (a7)+,a2
  1442.     tst.l    d0
  1443.     rts
  1444.  
  1445. ; --------------------------------------------------------------
  1446. ; Fetch one floating point number
  1447.  
  1448. FETCH_F:
  1449.     movem.l a2,-(a7)
  1450.  
  1451.     move.w    CA.GTFP,a2
  1452.     bsr.s    GET_ONE
  1453.     bne.s    FETCH_FX
  1454.  
  1455.     move.l    a1,BV_RIP(a6)
  1456.     move.w    0(a6,a1.l),d1
  1457.     move.l    2(a6,a1.l),d2
  1458.     addq.l    #6,BV_RIP(a6)
  1459.  
  1460. FETCH_FX:
  1461.     movem.l (a7)+,a2
  1462.     tst.l    d0
  1463.     rts
  1464.  
  1465. ; --------------------------------------------------------------
  1466. ; Fetch one string
  1467.  
  1468. FETCH_S:
  1469.     movem.l a2,-(a7)
  1470.  
  1471.     move.w    CA.GTSTR,a2
  1472.     bsr.s    GET_ONE
  1473.     bne.s    FETCH_SX
  1474.  
  1475.     move.l    a1,BV_RIP(a6)
  1476.     moveq    #3,d1        ; get total length of string
  1477.     add.w    0(a6,a1.l),d1
  1478.     bclr    #0,d1
  1479.     add.l    d1,BV_RIP(a6)    ; and reset ri stack pointer
  1480.  
  1481. FETCH_SX:
  1482.     movem.l (a7)+,a2
  1483.     tst.l    d0
  1484.     rts
  1485.  
  1486. ; --------------------------------------------------------------
  1487. ;  This routine gets one parameter and returns it on the maths
  1488. ;  stack, pointed to by (A1).
  1489. ;
  1490. ; Entry: A2.L    routine to call (i.e. CA.GTINT)
  1491. ;    A3.L   pointer to first parameter
  1492. ;    A5.L   pointer to last parameter
  1493. ;
  1494. ; Exit: A3.L   updated
  1495. ;    A5.L   updated
  1496. ;    A1.L   updated pointer to top of maths stack
  1497. ;    D0.L   error code
  1498. ;
  1499.  
  1500. GET_ONE:
  1501.     movem.l d1-d6/a0/a2,-(a7)
  1502.  
  1503.     lea    8(a3),a0
  1504.     cmp.l    a0,a5
  1505.     blt.s    GET_ONEBp
  1506.  
  1507.     move.l    BV_RIP(a6),a1
  1508.     move.l    a5,-(a7)
  1509.     move.l    a0,a5
  1510.     move.l    a5,-(a7)
  1511.     jsr    (a2)
  1512.     movem.l (a7)+,a0/a5
  1513.  
  1514.     tst.l    d0
  1515.     bne.s    GET_ONEX
  1516.  
  1517.     move.l    a0,a3
  1518.     move.l    a1,BV_RIP(a6)
  1519.  
  1520.     bra.s    GET_ONEX
  1521.  
  1522. GET_ONEBp:
  1523.     moveq    #ERR.BP,d0
  1524.  
  1525. GET_ONEX:
  1526.     movem.l (a7)+,d1-d6/a0/a2
  1527.     tst.l    d0
  1528.     rts
  1529.  
  1530. ; --------------------------------------------------------------
  1531. ; Get a filename on the stack
  1532. ;
  1533. ; Entry: A3.L    pointer to first parameter
  1534. ;    A5.L   pointer to last parameter
  1535. ;
  1536. ; Exit: A3.L   updated
  1537. ;    A5.L   updated
  1538. ;    D0.L...error code
  1539. ;    A1.L   pointer to string on math stack
  1540.  
  1541. GET1_FNAMES:
  1542.     movem.l d1/d4/d6/a2,-(a7)
  1543.  
  1544.     cmp.l    a3,a5
  1545.     beq    GET1_BP
  1546.  
  1547.     move.l    BV_RIP(a6),a1
  1548.  
  1549.     tst.w    2(a6,a3.l)    ; Test for parameter name
  1550.     bmi.s    GET1_STR    ; none? ...must be exprssn.
  1551.  
  1552.     moveq    #$0f,d0     ; extract type of parameter.
  1553.     and.b    1(a6,a3.l),d0
  1554.     subq.b    #1,d0        ; is it a string?
  1555.     bne.s    GET1_NAM    ; no, use name instead
  1556.  
  1557. GET1_STR:
  1558.     move.l    a5,-(sp)    ; save the top pointer
  1559.     lea    8(a3),a5    ; get just one string
  1560.     move.w    CA.GTSTR,a2
  1561.     jsr    (a2)
  1562.     move.l    (sp)+,a5    ; restore top pointer
  1563.     tst.l    d0
  1564.     bne.s    GET1_RTS
  1565.  
  1566.     move.l    a1,BV_RIP(a6)
  1567.     moveq    #3,d1        ; get total length of string
  1568.     add.w    0(a6,a1.l),d1
  1569.     bclr    #0,d1
  1570.     add.l    d1,BV_RIP(a6)    ; and reset ri stack pointer
  1571.     bra.s    GET1_OK
  1572.  
  1573. GET1_NAM:
  1574.     moveq    #0,d1
  1575.     move.w    2(a6,a3.l),d1    ; pointer to real entry
  1576.     bmi.s    GET1_BP     ; ... expression is no good
  1577.  
  1578.     lsl.l    #3,d1        ; in multiples of 8 bytes
  1579.     add.l    BV_NTBAS(a6),d1
  1580.     moveq    #0,d6
  1581.     move.w    2(a6,d1.l),d6    ; pointer to the name
  1582.     add.l    BV_NLBAS(a6),d6
  1583.     moveq    #0,d1        ; get the length of the name
  1584.     move.b    0(a6,d6.l),d1    ; as a long word.
  1585.     addq.l    #1,d1        ; rounded up
  1586.     bclr    #0,d1
  1587.     move.w    d1,d4        ; and save it
  1588.     addq.l    #2,d1        ; space required is +2 bytes
  1589.     move.w    BV.CHRIX,a2    ; on ri stack
  1590.     jsr    (a2)
  1591.     move.l    BV_RIP(a6),a1
  1592.     add.w    d4,d6        ; move to end of string
  1593.  
  1594. GET1_NMLUP:
  1595.     subq.l    #1,a1        ; copy one byte at a time
  1596.     move.b    0(a6,d6.l),0(a6,a1.l)
  1597.     subq.l    #1,d6
  1598.     dbra    d4,GET1_NMLUP    ; including the (byte) name
  1599. *                  length
  1600.     subq.l    #1,a1        ; put a zero on to make it a
  1601.     clr.b    0(a6,a1.l)    ; word
  1602.  
  1603. GET1_OK:
  1604.     lea    8(a3),a3    ; update parameter pointer
  1605.     moveq    #ERR.OK,d0
  1606.     bra.s    GET1_RTS
  1607.  
  1608. GET1_BP:
  1609.     moveq    #ERR.BP,d0
  1610.  
  1611. GET1_RTS:
  1612.     tst.l    d0
  1613.     movem.l (a7)+,d1/d4/d6/a2
  1614.     rts
  1615.  
  1616. ; --------------------------------------------------------------
  1617. ;  Get channel parameter
  1618.  
  1619. ; Entry: A3.L    pointer to first parameter
  1620. ;    A5.L   pointer to last parameter
  1621. ;    D1.L   default channel #
  1622. ;
  1623. ; Exit: A0.L   CH.ID (default d1)
  1624. ;    A2.L   CH.BASE
  1625. ;    A3.L   updated
  1626. ;    A5.L   updated
  1627. ;    D0.L   error code
  1628. ;
  1629.  
  1630. FETCH_CH:
  1631.     movem.l d1/d3/a1,-(a7)
  1632.  
  1633.     move.l    BV_RIP(a6),a1
  1634.     cmp.l    a3,a5
  1635.     beq.s    FETCH_CH1
  1636.  
  1637.     btst    #7,1(a6,a3.l)
  1638.     beq.s    FETCH_CH1
  1639.  
  1640.     bsr    FETCH_W
  1641.     bne.s    FETCH_CHX
  1642.  
  1643. FETCH_CH1:
  1644.     mulu    #$28,d1
  1645.     add.l    BV_CHBAS(a6),d1
  1646.     cmp.l    BV_CHP(a6),d1
  1647.     bge.s    FETCH_CHNO
  1648.  
  1649.     move.l    d1,a2
  1650.     move.l    0(a6,a2.l),a0
  1651.     move.w    a0,d1
  1652.     bmi.s    FETCH_CHNO
  1653.  
  1654.     moveq    #ERR.OK,d0
  1655.     bra.s    FETCH_CHX
  1656.  
  1657. FETCH_CHNO:
  1658.     moveq    #ERR.NO,d0
  1659.  
  1660. FETCH_CHX:
  1661.     movem.l (a7)+,d1/d3/a1
  1662.     rts
  1663.  
  1664. ; -------------------------------------------------------------
  1665. ; Get a job ID
  1666. ;
  1667. ; Entry: a3.L    pointer to first parameter
  1668. ;    a5.L   pointer to last parameter
  1669. ;
  1670. ; Exit: d1.l   JOB ID
  1671. ;    a3.L   updated
  1672. ;    a5.L   updated
  1673. ;    d0.L   error code
  1674.  
  1675. FETCH_ID:
  1676.     movem.l d2/d5,-(a7)
  1677.  
  1678.     move.l    a5,d5
  1679.     sub.l    a3,d5
  1680.     beq.s    ID_BP
  1681.  
  1682.     subq.w    #8,d5
  1683.     bne.s    ID_1
  1684.  
  1685.     bsr    FETCH_L     ; JOB ID
  1686.     bra.s    ID_X
  1687.  
  1688. ID_1:
  1689.     subq.w    #8,d5
  1690.     bne.s    ID_BP
  1691.  
  1692.     bsr.s    COMMA
  1693.     bne.s    ID_BP
  1694.  
  1695.     bsr    FETCH_W     ; JOB No
  1696.     bne.s    ID_X
  1697.     move.w    d1,d2
  1698.     swap    d2
  1699.  
  1700.     bsr    FETCH_W     ; JOB tag
  1701.     bne.s    ID_X
  1702.     move.w    d1,d2
  1703.     move.l    d2,d1
  1704.  
  1705.     moveq    #ERR.OK,d0
  1706.     bra.s    ID_X
  1707.  
  1708. ID_BP:
  1709.     moveq    #ERR.BP,d0
  1710.  
  1711. ID_X:
  1712.     movem.l (a7)+,d2/d5
  1713.     rts
  1714.  
  1715. ; -------------------------------------------------------------
  1716. COMMA:
  1717.     move.b    1(a6,a3.l),d0
  1718.     and.w    #$70,d0
  1719.     cmpi.b    #$10,d0     ; ','
  1720.     rts
  1721.  
  1722. BKSLSH:
  1723.     move.b    1(a6,a3.l),d0
  1724.     and.w    #$70,d0
  1725.     cmpi.b    #$30,d0     ; '\'
  1726.     rts
  1727.  
  1728. ; -------------------------------------------------------------
  1729. ;  Return true or false back to BASIC
  1730.  
  1731. RET_FLS:
  1732.     moveq    #0,d1
  1733.     bra.s    RET_W
  1734.  
  1735. RET_TRU:
  1736.     moveq    #1,d1
  1737.  
  1738. ; --------------------------------------------------------------
  1739. ;  Return word d1.w to BASIC
  1740.  
  1741. RET_W:
  1742.     move.l    d1,d4
  1743.     moveq.l #2,d1
  1744.     move.w    BV.CHRIX,a2
  1745.     jsr    (a2)
  1746.     move.l    d4,d1
  1747.  
  1748.     move.l    BV_RIP(a6),a1    ; Get arith stack pointer
  1749.     subq.l    #2,a1        ; room for 2 bytes
  1750.     move.l    a1,BV_RIP(a6)
  1751.     move.w    d1,0(a6,a1.l)    ; Put int number on stack
  1752.     moveq.l #3,d4        ; set Integer type
  1753.  
  1754.     moveq.l #ERR.OK,d0    ; no errors
  1755.     rts
  1756.  
  1757. ; -------------------------------------------------------------
  1758. ;    Return long Integer d1.l to BASIC
  1759.  
  1760. RET_L:
  1761.     move.l    d1,d4
  1762.     moveq.l #6,d1
  1763.     move.w    BV.CHRIX,a2
  1764.     jsr    (a2)
  1765.     move.l    d4,d1
  1766.  
  1767.     bsr.s    CONV_L2F
  1768.     subq.l    #6,BV_RIP(a6)
  1769.     move.l    BV_RIP(a6),a1
  1770.     move.w    d2,0(a6,a1.l)
  1771.     move.l    d1,2(a6,a1.l)
  1772.     moveq.l #2,d4
  1773.  
  1774.     moveq.l #ERR.OK,d0
  1775.     rts
  1776.  
  1777. ; -------------------------------------------------------------
  1778. ;  convert long Integer to floating point form.
  1779. ;  Entry: d1.l = long int
  1780. ;  Exit:  d1.w = mantissa
  1781. ;     d2.l = exponent
  1782.  
  1783. CONV_L2F:
  1784.     move.l    d1,d2
  1785.     beq.s    CONV_L2FX
  1786.  
  1787.     move.w    #$81F,d2
  1788.     move.l    d1,-(a7)
  1789.  
  1790. CONV_L2F1:
  1791.     add.l    d1,d1
  1792.     bvs.s    CONV_L2F2
  1793.  
  1794.     subq.w    #1,d2
  1795.     move.l    d1,(a7)
  1796.     bra.s    CONV_L2F1
  1797.  
  1798. CONV_L2F2:
  1799.     move.l    (a7)+,d1
  1800.  
  1801. CONV_L2FX:
  1802.     rts
  1803.  
  1804. ; -------------------------------------------------------------
  1805. ;    Return 4 character string d1.l to BASIC
  1806.  
  1807. RET_4S:
  1808.     move.l    d1,d4
  1809.     moveq.l #6,d1
  1810.     move.w    BV.CHRIX,a2
  1811.     jsr    (a2)
  1812.     move.l    d4,d1
  1813.  
  1814.     subq.l    #6,BV_RIP(a6)
  1815.     move.l    BV_RIP(a6),a1
  1816.     move.w    #4,0(a6,a1.l)
  1817.     move.l    d1,2(a6,a1.l)
  1818.     moveq    #1,d4
  1819.  
  1820.     moveq    #ERR.OK,d0
  1821.     rts
  1822.  
  1823. ; -------------------------------------------------------------
  1824. ;    print string at (a1) to channel with id a0
  1825.  
  1826. IOSTRG:
  1827.     movem.l d1-d3/a1-a2,-(a7)
  1828.  
  1829.     move.w    UT.MTEXT,a2
  1830.     jsr    (a2)
  1831.  
  1832.     movem.l (a7)+,d1-d3/a1-a2
  1833.     rts
  1834.  
  1835. ; --------------------------------------------------------------
  1836. RPORT.OR moveq    #ERR.OR,d0
  1837.     rts
  1838.  
  1839. RPORT.NO moveq    #ERR.NO,d0
  1840.     rts
  1841.  
  1842. RPORT.BP moveq    #ERR.BP,d0
  1843.     rts
  1844.  
  1845. ; --------------------------------------------------------------
  1846.  
  1847.     END
  1848.